home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / a-nuranu.adb < prev    next >
Text File  |  1994-05-19  |  6KB  |  187 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                  A D A . N U M E R I C S _ R A N D O M                   --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.2 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. --  This implementation is derived from LSN 1055 written by Ken Dritz.
  26.  
  27. with Calendar; use Calendar;
  28. with Unchecked_Deallocation;
  29.  
  30. package body Ada.Numerics.Random_Numbers is
  31.  
  32.    -----------------------
  33.    -- Local Subprograms --
  34.    -----------------------
  35.  
  36.    procedure Destroy_State is
  37.       new Unchecked_Deallocation (Internal_State, Access_State);
  38.  
  39.    function Make_Internal_State (Starter : Integer) return Internal_State;
  40.    --  This function is used in this implementation to produce a valid
  41.    --  internal state for the Fibonacci generator based on an integer
  42.    --  that is a valid internal state for a linear congruential generator
  43.    --  It uses the latter to generate random bits with which to initialize
  44.    --  the state vector.
  45.  
  46.    -------------------------
  47.    -- Make_Internal_State --
  48.    -------------------------
  49.  
  50.    function Make_Internal_State (Starter : Integer) return Internal_State is
  51.       Bit_Value      : Float;
  52.       T              : State_Vector;
  53.       LCG_State      : Float;
  54.       LCG_Multiplier : constant := 16_807.0;
  55.       LCG_Modulus    : constant := 2_147_483_647.0;
  56.  
  57.       function LCG_Random return Uniformly_Distributed is
  58.          T : Float;
  59.          I : Integer;
  60.  
  61.       begin
  62.          T := LCG_State * LCG_Multiplier;
  63.          I := Integer (T / LCG_Modulus);
  64.          LCG_State := T - Float (I) * LCG_Modulus;
  65.  
  66.          if LCG_State < 0.0 then
  67.             LCG_State := LCG_State + LCG_Modulus;
  68.          end if;
  69.  
  70.          return LCG_State / LCG_Modulus;
  71.       end LCG_Random;
  72.  
  73.    --  Start of processing for Make_Internal_State
  74.  
  75.    begin
  76.       LCG_State := Float (Starter);
  77.  
  78.       for I in Lag_Range loop
  79.          T (I) := 0.0;
  80.          Bit_Value := 1.0;
  81.  
  82.          for J in 1 .. 24 loop
  83.             Bit_Value := Bit_Value * 0.5;
  84.  
  85.             if LCG_Random >= 0.5 then
  86.                T (I) := T (I) + Bit_Value;
  87.             end if;
  88.          end loop;
  89.       end loop;
  90.  
  91.       return (Lagged_Outputs => T,
  92.               Borrow         => 0.0,  -- arbitrary
  93.               R              => Larger_Lag - 1,
  94.               S              => Smaller_Lag - 1);
  95.    end Make_Internal_State;
  96.  
  97.    ------------
  98.    -- Random --
  99.    ------------
  100.  
  101.    function Random (Gen : Generator) return Uniformly_Distributed is
  102.       U : Float;
  103.  
  104.    begin
  105.       U := Gen.State.Lagged_Outputs (Gen.State.R) -
  106.            Gen.State.Lagged_Outputs (Gen.State.S) -
  107.            Gen.State.Borrow;
  108.  
  109.       if U < 0.0 then
  110.          U := U + 1.0;
  111.          Gen.State.Borrow := 2#1.0#e-24;
  112.       else
  113.          Gen.State.Borrow := 0.0;
  114.       end if;
  115.  
  116.       Gen.State.Lagged_Outputs (Gen.State.R) := U;
  117.       Gen.State.R := Gen.State.R - 1;
  118.       Gen.State.S := Gen.State.S - 1;
  119.       return U;
  120.    end Random;
  121.  
  122.    --------------------
  123.    -- Random_Integer --
  124.    --------------------
  125.  
  126.    function Random_Integer
  127.      (Gen       : Generator;
  128.       Low, High : Integer)
  129.       return    Integer
  130.    is
  131.       Spread : constant Positive := High - Low + 1;
  132.       --  Propagate Constraint_Error if overflow or if Low > High.
  133.  
  134.    begin
  135.       return Low + Integer (Float (Spread) * Random (Gen)) mod Spread;
  136.    end Random_Integer;
  137.  
  138.    -----------
  139.    -- Reset --
  140.    -----------
  141.  
  142.    procedure Reset (Gen : in Generator; Initiator : in Integer) is
  143.    begin
  144.       Gen.State.all :=
  145.         Make_Internal_State (Initiator mod 2_147_483_646 + 1);
  146.    end Reset;
  147.  
  148.    procedure Reset (Gen : in Generator) is
  149.       Yr  : Year_Number;
  150.       Mo  : Month_Number;
  151.       Dy  : Day_Number;
  152.       Se  : Day_Duration;
  153.       S   : Natural range 0 .. 86_400;
  154.       Sec : Natural range 0 .. 59;
  155.       Min : Natural range 0 .. 59;
  156.       Hr  : Natural range 0 .. 23;
  157.       T   : Natural;
  158.  
  159.    begin
  160.       Split (Clock, Yr, Mo, Dy, Se);
  161.       S   := Natural (Se);
  162.       Sec := S mod 60;
  163.       S   := S / 60;
  164.       Min := S mod 60;
  165.       Hr  := S / 60;
  166.       T   := ((((Sec * 60 + Min) * 24 + Hr) * 32 + Dy) * 13 + Mo) * 50 +
  167.              (Yr mod 50) + 26_000_000;
  168.       Gen.State.all := Make_Internal_State (T);
  169.    end Reset;
  170.  
  171.    --------------
  172.    -- Finalize --
  173.    --------------
  174.  
  175.    procedure Finalize (Gen : in out Generator) is
  176.    begin
  177.       Destroy_State (Gen.State);
  178.    end Finalize;
  179.  
  180. --  Package initialization initializes Initial_State
  181.  
  182. begin
  183.  
  184.    Initial_State := Make_Internal_State (30_000_000);
  185.  
  186. end Ada.Numerics.Random_Numbers;
  187.